home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Monster Media 1994 #2
/
Monster Media No. 2 (Monster Media)(1994).ISO
/
prog_pas
/
ddplus63.zip
/
DDSCOTT.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-01-22
|
9KB
|
458 lines
unit ddscott;
interface
uses dos,crt;
type
adaptertype= (MDA,CGA,EGAMono,EGAColor);
datetype=string[6];
screentype= array[1..4000] of byte;
screenptr=^screentype;
var
screen: screenptr;
x,y: integer;
ch: char;
DOS_Major,DOS_Minor,Os2Vers : Word;
hexon,OS2OK,WinOK,DVOK : Boolean;
function va(n: integer): string;
function wva(n: word): string;
function lva(n: longint): string;
function rva(n: real): string;
function stu(s: string): string;
function locase(c: char): char;
function stl(s: string): string;
function namestr(s: string): string;
function exist(file_name: string): boolean;
procedure delete_file(fn: string);
procedure setmode(modenumber: byte);
{ procedure set43lines; }
procedure set25lines;
function isega: boolean;
function queryadaptertype: adaptertype;
function determinepoints: integer;
procedure cursoron;
procedure cursoroff;
procedure cursorblock;
function screenaddress: word;
procedure savescreen;
procedure restorescreen;
function date: datetype;
function bitcheck(n: word; b: byte): boolean;
procedure setbit(var n: word; b: byte);
procedure resetbit(var n: word; b: byte);
function DosVer(var Minor : Word) : Word;
function hex(i: byte): string;
procedure HexFilt(var s: string);
procedure HexToDec(var s: string);
implementation
function hex(i: byte): string;
const
ss: string='0123456789ABCDEF';
var
hibyte,lobyte: byte;
begin;
hibyte:=i div 16;
lobyte:=i-((i div 16)*16);
hex:=ss[hibyte+1]+ss[lobyte+1];
end;
procedure HexFilt(var s: string);
var
s2,s3: string;
numst: string;
r: real;
a,b: integer;
e: integer;
d: longint;
c: array[1..4] of byte absolute d;
begin;
s:=s+#13;
s2:='';
numst:='';
for a:=1 to length(S) do begin;
if s[a] in ['0'..'9'] then numst:=numst+s[a] else begin;
if (numst<>'') then begin;
val(numst,r,b);
str(r:0:0,s3);
val(s3,r,b);
e:=a-1;
b:=0;
repeat
e:=e+1;
if upcase(s[e])='H' then b:=1;
until (s[e]=' ') or (e>=length(s)) or (s[e]=#13) or (s[e]=#10);
if (r<2000000000) and (b=0) then begin;
d:=trunc(r);
numst:=hex(c[4])+hex(c[3])+hex(c[2])+hex(c[1]);
while (length(numst)>0) and (numst[1]='0') do delete(numst,1,1);
if (length(numst)=0) or (not (numst[1] in ['0'..'9'])) then numst:='0'+numst;
numst:=numst+'h';
end;
s2:=s2+numst;
numst:='';
end;
s2:=s2+s[a];
end;
end;
delete(s2,length(s2),1);
s:=s2;
end;
procedure HexToDec(var s: string);
const
ss: string ='0123456789ABCDEF';
var
d: longint;
c: array[1..4] of byte absolute d;
begin;
if length(s)=0 then exit;
if upcase(s[length(s)])<>'H' then exit;
if not (s[1] in ['0'..'9']) then exit;
delete(s,length(s),1);
if length(s)=0 then exit;
while length(s)<8 do s:='0'+s;
c[1]:=(pos(upcase(s[8]),ss)-1)+(pos(upcase(s[7]),ss)-1)*16;
c[2]:=(pos(upcase(s[6]),ss)-1)+(pos(upcase(s[5]),ss)-1)*16;
c[3]:=(pos(upcase(s[4]),ss)-1)+(pos(upcase(s[3]),ss)-1)*16;
c[4]:=(pos(upcase(s[2]),ss)-1)+(pos(upcase(s[1]),ss)-1)*16;
str(d,s);
end;
procedure delete_file(fn: string);
var
f: file;
begin;
assign(f,fn);
erase(f);
end;
function va(n: integer): string;
var
v: string;
begin;
str(n,v);
if hexon then hexfilt(v);
va:=v;
end;
function wva(n: word): string;
var
v: string;
begin;
str(n,v);
if hexon then hexfilt(v);
wva:=v;
end;
function lva(n: longint): string;
var
v: string;
begin;
str(n,v);
if hexon then hexfilt(v);
lva:=v;
end;
function rva(n: real): string;
var
v: string;
begin;
str(n:0:0,v);
if hexon then hexfilt(v);
rva:=v;
end;
function stu(s: string): string;
var
a: integer;
begin;
for a:=1 to length(s) do s[a]:=upcase(s[a]);
stu:=s;
end;
function locase(c: char): char;
begin;
if (c>='A') and (c<='Z') then c:=chr(ord(c)+32);
locase:=c;
end;
function stl(s: string): string;
var
a: integer;
begin;
for a:=1 to length(s) do s[a]:=locase(s[a]);
stl:=s;
end;
Function exist(file_name: string): boolean;
var
f: text;
b: boolean;
begin;
assign(f,file_name);
{$I-} reset(f); {$I+}
if ioresult<>0 then b:=false else b:=true;
if b then close(f);
exist:=b;
end;
function namestr(s: string): string;
var
a: integer;
begin;
s:=stl(s);
if length(s)>2 then begin;
s[1]:=upcase(s[1]);
for a:=1 to length(s) do begin;
if (s[a] in ['.',' ',',',':',';','-','_','(',')']) and (a+1<length(s)) then s[a+1]:=upcase(s[a+1]);
end;
end;
namestr:=s;
end;
procedure setmode(modenumber: byte);
var
regs: registers;
begin;
regs.ah:=0;
regs.al:=modenumber;
intr($10,regs);
end;
procedure set25lines;
var
regs: registers;
begin;
regs.ax:=$1111;
regs.bx:=0;
intr($10,regs);
mem[$40:$87]:=mem[$40:$87] or $01;
regs.ax:=$100;
regs.bx:=0;
regs.cx:=$0C00;
intr($10,regs);
end;
function isega: boolean;
var
regs: registers;
begin;
regs.ah:=$12;
regs.bx:=$10;
intr($10,regs);
if regs.bx=$10 then isega:=false else isega:=true;
end;
function QueryAdapterType: Adaptertype;
var
regs: registers;
code: byte;
begin;
if isega then begin;
regs.ah:=$12;
regs.bx:=$10;
intr($10,regs);
if (regs.bh=0) then queryadaptertype:=egacolor else queryadaptertype:=egamono;
end else begin;
intr($11,regs);
code:=(regs.al and $30) shr 4;
case code of
1: queryadaptertype:=cga;
2: queryadaptertype:=cga;
3: queryadaptertype:=mda;
else queryadaptertype:=cga;
end;
end;
end;
procedure cursoroff;
var
regs: registers;
begin;
regs.ax:=$0100;
regs.cx:=$2000;
intr($10,regs);
end;
function determinepoints: integer;
var
regs: registers;
begin;
case queryadaptertype of
cga: determinepoints:=8;
mda: determinepoints:=14;
egamono, egacolor: begin;
regs.ax:=$1130;
regs.bx:=0;
intr($10,regs);
determinepoints:=regs.cx;
end;
end;
end;
procedure cursoron;
var
regs: registers;
begin;
regs.ax:=$0100;
regs.ch:=determinepoints-2;
regs.cl:=determinepoints-1;
intr($10,regs);
end;
procedure cursorblock;
var
regs: registers;
begin;
regs.ax:=$0100;
regs.ch:=1;
regs.cl:=determinepoints-1;
intr($10,regs);
end;
function screenaddress: word;
begin;
case queryadaptertype of
cga: screenaddress:=$B800;
mda: screenaddress:=$b000;
egamono: screenaddress:=$b000;
egacolor: screenaddress:=$b800;
end;
end;
procedure savescreen;
var
sc1: byte absolute $b000:0;
sc2: byte absolute $b800:0;
begin;
if screenaddress=$b000 then move(sc1,screen^,4000);
if screenaddress=$b800 then move(sc2,screen^,4000);
x:=wherex;
y:=wherey;
end;
procedure restorescreen;
var
sc1: byte absolute $b800:0;
sc2: byte absolute $b000:0;
begin;
if screenaddress=$b000 then move(screen^, sc2,4000);
if screenaddress=$b800 then move(screen^, sc1,4000);
gotoxy(x,y);
end;
function date: datetype;
var
d,m,y,dow: word;
s,s2: string[6];
begin;
getdate(y,m,d,dow);
y:=y-1900;
s:=va(m);
if length(s)=1 then s:='0'+s;
s2:=va(d);
if length(s2)=1 then s2:='0'+s2;
s:=s+s2;
s2:=va(y);
if length(s2)=1 then s2:='0'+s2;
s:=s+s2;
date:=s;
end;
function bitcheck(n: word; b: byte): boolean;
var
a,c: integer;
begin;
a:=2;
for c:=1 to b do a:=a*2;
if (a and n)<>0 then bitcheck:=true else bitcheck:=false;
end;
procedure setbit(var n: word; b: byte);
var
a,c: integer;
begin;
a:=2;
for c:=1 to b do a:=a*2;
n:=(a or n);
end;
procedure resetbit(var n: word; b: byte);
var
a,c: integer;
begin;
a:=2;
for c:=1 to b do a:=a*2;
a:= not a;
n:=(a and n);
end;
function DosVer(var Minor : Word) : Word;
var
Reg : Registers;
Begin
with Reg do begin { AH := $30 is needed }
Ax := $3000;
MsDos(Reg);
DosVer := Al;
Minor := Ah;
end;
end;
Function Win3_On: boolean;
const
Multplx_intr = $2F;
var
Regs : registers;
begin
With Regs do
begin
AX := $1600;
Intr(Multplx_intr,regs); { $00 no Win 2.x or 3.x }
if AL in [$00,$01,$80,$FF] then { $01 Win/386 2.x running }
Win3_On := false { $80 obsolete XMS installed }
else { $FF Win/386 2.x running }
Win3_On := true;
end;
end;
Function DVCheck_On: boolean;
const
DV_intr = $15;
var
Regs : registers;
begin
With Regs do
begin
AH := $2B;
CX := $4445;
DX := $5351;
AL := $01;
Intr(DV_intr,regs);
If AL = $FF then
DVCheck_On := false
else
DVCheck_On := true;
end;
end;
begin
OS2OK := false;
DVOK := DvCheck_On;
If Not DVOK then
begin
WinOK := Win3_On;
If Not WinOK then
begin
DOS_Major := DosVer(DOS_Minor); { Win/NT returns Dos 5.00 }
Case Dos_Major of
5..9 : WinOK := true;
10..29 : OS2Ok := true; { OS2 1.0 = 10/ 2.0 = 20 }
end;
end;
end;
hexon:=false;
new(screen);
end.